home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 2003 February / macformat-126.iso / Shareware⁄Freeware (OS X) / Business / BLT X 0.2 / BLT0.2.0.dmg / BLT.app / Contents / Resources / linkchecker.pl < prev    next >
Encoding:
Perl Script  |  2002-12-02  |  15.1 KB  |  647 lines
  1. #!/usr/bin/perl -w
  2. # Script Version 1.2
  3. ###############################################################
  4. #              Welcome to the Link Checker script.            #
  5. # The rules are simple: I would love to have my coding fixed. #
  6. #             Send emails to <braxton@braxtech.com>           #
  7. #                please don't pick nits though.               #
  8. ###############################################################
  9. # Licensed under the BSPL:                                    #
  10. # 1) If it's immoral, discrediting, or just downright         #
  11. #    insulting don't do it.                                   #
  12. # 2) If in doubt, email me.                                   #
  13. # Take care, and happy scripting, Braxton Sherouse.           #
  14. ###############################################################
  15.  
  16. use strict;
  17.  
  18. # Functions
  19. sub doCollectLinks($);
  20. sub doCheckLinks(@);
  21. sub URLExists($);
  22. sub fileExists($);
  23. sub combinePaths($$$);
  24. sub printResult($$$$);
  25. sub mortallyWounded($$$);
  26. sub debugMessage($$$);
  27.  
  28. sub isURL($);
  29. sub isRecursableFile($);
  30. sub isRecursableURL($);
  31.  
  32. ## Default Values for Arguments
  33. my $verbose=0;
  34. my $postponeURLs=1;
  35. my $easyparse=0;
  36. my $connecttimeout=".5";
  37. my $totaltimeout="5";
  38. my $userAgent="BLT(LinkChecker0.2)";
  39. my $recurse=0; 
  40. my $skipComments=0;
  41. my $showEmailLinks=0;
  42. my $showLineNumbers=0;
  43. my @defaultFiles; #given default values later.
  44.  
  45. ## Global Constants
  46. my @args=@ARGV;
  47. my $DEBUG=0;
  48. my $userhome=$ENV{HOME};
  49. my %linkStatus=(failure            =>0,
  50.         success            =>1,
  51.         email            =>2,
  52.         protocolError        =>3,
  53.         forbidden        =>4,
  54.         timeout            =>5,
  55.         anchor            =>6);
  56.  
  57. ## Global Declarations
  58. my $rootdir;
  59. my $startloc;
  60. my %URLResultCache;
  61. my %forwardingURLs;
  62. my @processedlinks;
  63. my @postponedURLs;
  64.  
  65.  
  66. parseArgs();
  67. if ($DEBUG)
  68.  {
  69.   debugMessage("userhome","$userhome",__LINE__);
  70.   debugMessage("rootdir","$rootdir",__LINE__);
  71.   debugMessage("startloc","$startloc",__LINE__);
  72.   debugMessage("postpone","$postponeURLs",__LINE__);
  73.   debugMessage("easyparse","$easyparse",__LINE__);
  74.   debugMessage("connecttimeout","$connecttimeout",__LINE__);
  75.   debugMessage("totaltimeout","$totaltimeout",__LINE__);
  76.   debugMessage("recurse","$recurse",__LINE__);
  77.   debugMessage("useragent","$userAgent",__LINE__);
  78.  }
  79.  
  80. if ((isURL($startloc) && (URLExists($startloc)==$linkStatus{'success'})) || (!isURL($startloc) && fileExists($startloc)))
  81.  {
  82.   print "::: v :: rootdir :: $rootdir :: __LINE__ :::\n" if ($easyparse && $showLineNumbers);
  83.   doCheckLinks(doCollectLinks($startloc));
  84.   checkPostponedURLs();
  85.  }
  86. else
  87.  {mortallyWounded("starting location","doesn't exist",__LINE__);}
  88.  
  89. sub doCollectLinks($){
  90. my $page=shift;
  91. my $work;
  92. my @temparray;
  93. my $baseurl="";
  94. my $in;
  95.  
  96. debugMessage("doCollectLinks(\$)","$page",__LINE__) if $DEBUG;
  97.  
  98. while ($forwardingURLs{$page})
  99.  {$page=$forwardingURLs{$page};}
  100.  
  101. if (isURL($page))
  102.  {$in="curl --connect-timeout $connecttimeout -A \"$userAgent\" --max-time $totaltimeout \"$page\" -s |";}
  103. else
  104.  {$in=$page;}
  105.  
  106. open IN, $in                 or mortallyWounded("doCollectLinks","file disappeared: $page",__LINE__);
  107. open OUT, ">$userhome/.tempout.txt" or mortallyWounded("doCollectLinks","couldn't create ~/.tempout.txt",__LINE__);
  108.  
  109. while (<IN>) {$work.=$_;}
  110. $work=~s|<!--(.*?)-->||gs if $skipComments; 
  111. print OUT $work;
  112. close OUT;
  113. close IN;
  114.  
  115. open IN, "$userhome/.tempout.txt" or mortallyWounded("doCollectLinks","couldn't open ~/.tempout.txt",__LINE__);
  116. while (<IN>) 
  117.  {
  118.   while (/<([^>]*)\s+(href|src|background)\s*=\s*(\"|\')(\S*)(\"|\')[^>]*>/gmi) 
  119.    {
  120.     my $tagname=$1;
  121.     my $reftype=$2;
  122.     my $content=$4;
  123.     if ($content!~/^javascript:/)
  124.     {
  125.     if ($baseurl)
  126.      {push @temparray, {url=>combinePaths($content,$baseurl,0),line=>$.,hasbase=>$baseurl};}
  127.     else
  128.      {push @temparray, {url=>$content,line=>$.};}
  129.      }
  130.     if ($tagname=~/^base/i && $reftype=~/^href$/i)
  131.      {$baseurl=$content;}
  132.    }
  133.  }
  134. close IN;
  135.  
  136. unlink "$userhome/.tempout.txt";
  137.  
  138. push @temparray, "$page"; #it's the first thing to get popped later.
  139. return @temparray;
  140. }
  141.  
  142. sub doCheckLinks(@){
  143. my @linkarray=@_;
  144. my $from=pop @linkarray;
  145.  
  146. debugMessage("doCheckLinks(\@)","$from",__LINE__) if $DEBUG;
  147.  
  148. if (!grep /^$from$/i, @processedlinks)
  149.  {
  150.   push @processedlinks, $from;
  151.   if (isURL($from) && $from=~m#/$#)
  152.    {
  153.     foreach my $deffile (@defaultFiles)
  154.      {
  155.       if (!grep /^$from$deffile$/i,@processedlinks)
  156.        {push @processedlinks,"$from$deffile";}
  157.      }
  158.    }
  159.   for (my $a=0;$a<scalar @linkarray;$a++)
  160.    {
  161.     my $cururl=$linkarray[$a]{'url'};
  162.     my $hasbase=$linkarray[$a]{'hasbase'};
  163.     my $lineNumber=$linkarray[$a]{'line'};
  164.     my $combinedPath=combinePaths($cururl,$from,$hasbase);
  165.  
  166.     if (isURL($cururl) && $cururl!~/^$rootdir/i)
  167.      {
  168.       if ($postponeURLs)
  169.        {push @postponedURLs, {url=>$cururl,line=>$lineNumber,from=>$from};}
  170.       else 
  171.        {printResult(URLExists($combinedPath),$combinedPath,$from,$lineNumber);}
  172.      }
  173.     elsif ($cururl=~/mailto:(.*)/i)
  174.      {printResult($linkStatus{"email"},$1,$from,$lineNumber);}
  175.     elsif (!isURL($cururl) && $cururl=~m#(\w{2,6}://.*)#)
  176.      {printResult($linkStatus{"protocolError"},$1,$from,$lineNumber);}
  177.     elsif (!isURL($startloc) and !isURL($cururl))
  178.      {
  179.       my $success=fileExists($combinedPath);
  180.       printResult($success,$combinedPath,$from,$lineNumber);
  181.       if ($success && $recurse && $combinedPath=~/^$rootdir/ && isRecursableFile($combinedPath))
  182.        {doCheckLinks(doCollectLinks(replaceDirWithDefaultFile($combinedPath)));}
  183.      }
  184.     elsif(isURL($combinedPath))
  185.      {
  186.       my $success=URLExists($combinedPath);
  187.       printResult($success,$combinedPath,$from,$lineNumber);
  188.       if ($success && $recurse && $combinedPath=~/^$rootdir/ && isRecursableURL($combinedPath))
  189.        {doCheckLinks(doCollectLinks("$combinedPath"));}
  190.      }
  191.    }
  192.  }
  193. else {}
  194. }
  195.  
  196.  
  197. sub URLExists($){
  198. my $url=shift;
  199. my $returnValue=$linkStatus{"failure"}; # default to failure. just to be safe.
  200.  
  201. if ($url=~/#/)
  202.  {return $linkStatus{"anchor"};}
  203.  
  204. debugMessage("URLExists(\$)","$url",__LINE__) if $DEBUG;
  205.  
  206. if ($URLResultCache{$url})
  207.  {return $URLResultCache{$url};}
  208. else
  209.  {
  210.   $url=~m#(https?|ftp)://(.*)#i;
  211.   my $method=lc($1);
  212.   
  213.   #### eventually this should use --referer <URL> to send the referrer to the server.
  214.   open CURL, "curl -I --connect-timeout $connecttimeout -A \"$userAgent\" --max-time $totaltimeout \"$url\" -s -S --stderr - |" or mortallyWounded("URLExists","couldn't fork curl",__LINE__);
  215.   
  216.   while (<CURL>)
  217.    {
  218.     if (/^curl: \((\d+)\)/)
  219.     {
  220.      my $errorCode=$1;
  221.      debugMessage("curlSaid",$errorCode,__LINE__) if $DEBUG;
  222.  
  223.      if    ($errorCode==1)              {$returnValue=$linkStatus{'protocolError'};}
  224.      elsif ($errorCode>1 && $errorCode<9)     {$returnValue=$linkStatus{'failure'};}
  225.      elsif ($errorCode>8 && $errorCode<13)    {$returnValue=$linkStatus{'forbidden'};}
  226.      elsif ($errorCode==28)              {$returnValue=$linkStatus{'timeout'};}
  227.      last;
  228.     }
  229.     elsif ($method eq "http" and m|HTTP/\d\.\d (\d{3})\s?.*|i)
  230.      {
  231.       my $errorCode=$1;
  232.       debugMessage("webServerSaid",$errorCode,__LINE__) if $DEBUG;
  233.       
  234.       if ($errorCode eq "405")
  235.       {
  236.        # server gives "method not allowed" error. 
  237.        # Use GET to download the entire document... argh.
  238.        system ("curl --connect-timeout $connecttimeout -L -A \"$userAgent\" --max-time $totaltimeout $url -s > \"$userhome/.tempoutcurl.txt\"");
  239.        do {$returnValue=$linkStatus{'success'}; unlink "$userhome/.tempoutcurl.txt";} if (-s "$userhome/.tempoutcurl.txt");
  240.       }
  241.       elsif($errorCode=~/^2/)
  242.       {$returnValue=$linkStatus{"success"};}
  243.       elsif($errorCode=~/^3/)
  244.       {
  245.        do {$_=<CURL>;} until ($_=~/Location: (.*)/);
  246.        $forwardingURLs{$url}=$1;
  247.        $returnValue=URLExists($1);
  248.       }
  249.       elsif ($errorCode=~/^40(1|3)/)
  250.       {
  251.        $returnValue=$linkStatus{"forbidden"};
  252.       }
  253.       last;
  254.      }
  255.     elsif ($1 eq "ftp" and /Content-Length: (\d{0,20})/)
  256.      {
  257.       $returnValue=$linkStatus{"success"};
  258.       last;
  259.      }
  260.    }
  261.   close CURL;
  262.  
  263.  
  264.  
  265.   $URLResultCache{$url}=$returnValue;
  266.   
  267.   if ($url=~m#/$#)
  268.    {
  269.     foreach my $deffile (@defaultFiles)
  270.      {
  271.       if (!$URLResultCache{"$url$deffile"})
  272.        {$URLResultCache{"$url$deffile"}=$returnValue;}
  273.      }
  274.    }
  275.   else
  276.    {
  277.     # check to see if it is a default file. 
  278.     # if it is, add the directory.
  279.     $url=~m#(.+/)(.*)$#;
  280.     if (grep /^$2$/i,@defaultFiles)
  281.      {$URLResultCache{"$1"}=$returnValue;}
  282.    }
  283.   return $returnValue;
  284.   }
  285. }
  286.  
  287.  
  288. sub fileExists($){
  289. my $file=shift;
  290.  
  291. debugMessage("fileExists(\$)","$file",__LINE__) if $DEBUG;
  292.  
  293. if ($file=~/#/)
  294.  {return $linkStatus{"anchor"};}
  295.  
  296. $file=replaceDirWithDefaultFile($file);
  297.  
  298. if (-e "$file")
  299.  {return $linkStatus{"success"};}
  300. else
  301.  {return $linkStatus{"failure"};}
  302. }
  303.  
  304.  
  305.  
  306. sub checkPostponedURLs{
  307.  
  308. debugMessage("checkPostponedURLs()","()",__LINE__) if $DEBUG;
  309.  
  310. if ($verbose)
  311.  {
  312.   if (!$easyparse)
  313.    {print "                notice : switching to external links\n" if (scalar @postponedURLs>=1);}
  314.   else
  315.    {print "::: n :: switch :: external :: x :::\n" if (scalar @postponedURLs>=1);}
  316.  }
  317.  
  318. for(my $a=0;$a<scalar @postponedURLs;$a++)
  319. {
  320. printResult(URLExists($postponedURLs[$a]{'url'}),$postponedURLs[$a]{'url'},$postponedURLs[$a]{'from'},$postponedURLs[$a]{'line'});
  321. }
  322.  
  323. }
  324.  
  325. sub parseArgs{
  326. while (@args)
  327.  {
  328.   my $foo=pop @args;
  329.   if ($foo eq "-dp")
  330.    {$postponeURLs=0;}
  331.   elsif ($foo eq "-v")
  332.    {$verbose=1;}
  333.   elsif ($foo eq "-ep")
  334.    {$easyparse=1;}
  335.   elsif ($foo eq "-r")
  336.    {$recurse=1;}
  337.   elsif ($foo=~/--totaltimeout=(.*)/)
  338.    {$totaltimeout=$1;}
  339.   elsif ($foo=~/--connecttimeout=(.*)/)
  340.    {$connecttimeout=$1;}
  341.   elsif ($foo=~/--userAgent=(.*)/)
  342.    {$userAgent=$1;}
  343.   elsif ($foo=~/--defaultFiles=(.*)/)
  344.    {@defaultFiles=split /,/, $1, -64;}
  345.   elsif ($foo eq "--skipComments")
  346.    {$skipComments=1;}
  347.   elsif ($foo eq "--lineNumbers")
  348.    {$showLineNumbers=1;}
  349.   elsif ($foo eq "--emailLinks")
  350.    {$showEmailLinks=1;}
  351.   elsif ($foo=~/^-./)
  352.    {
  353.     print <<"   END";
  354. Invalid Argument. Options are:
  355.    [-dp]: don't postpone external links
  356.    [-v]: verbose mode
  357.    [-ep]: easy parse mode
  358.    [-r]: recursive checking
  359.    [--skipComments]: skip links in HTML comments
  360.    [--emailLinks]: show email links
  361.    [--totaltimeout=*]: total timeout
  362.    [--connecttimeout=*]: connect timeout
  363.    [--userAgent=*]: user agent
  364.    [--defaultFiles=*]: default files [comma separated]
  365.    END
  366.     exit 0;
  367.    }
  368.   else
  369.    {$startloc=$foo;}
  370.  }
  371.  
  372. if (!@defaultFiles)
  373.  {push @defaultFiles, ("index.html","index.htm","default.html","default.htm","index.shtml","default.shtml");}
  374. if (!$startloc)
  375.  {mortallyWounded("starting location","unspecified",__LINE__);}
  376.  
  377. if (isURL($startloc))
  378.  {
  379.   if ($startloc=~m|(.*)/$|)
  380.    {
  381.     $rootdir=$1;
  382.    }
  383.   elsif (isRecursableURL($startloc))
  384.    {
  385.     $startloc=~m|^(.*)/.*$|;
  386.     $rootdir=$1;
  387.    }
  388.   elsif (isRecursableURL("$startloc/"))
  389.    {
  390.     $rootdir=$startloc;
  391.     $startloc="$startloc/";
  392.    }
  393.   else
  394.    {mortallyWounded("starting location","not recursable",__LINE__);}
  395.  }
  396. else
  397.  {
  398.   if ($startloc=~m|(.*)/$|)
  399.    {
  400.     $rootdir=$1;
  401.     $startloc=replaceDirWithDefaultFile($startloc);
  402.     if ($startloc=~m|/$|)
  403.      {
  404.       # if replaceDir can't find a matching default file,
  405.       # we set the starting location to somethine we KNOW will fail
  406.       $startloc.="filethatdoesn'texist.html";
  407.      }
  408.    }
  409.   elsif (isRecursableFile($startloc))
  410.    {
  411.     $startloc=~m|^(.*)/.*$|;
  412.     $rootdir=$1;
  413.    }
  414.   elsif (isRecursableFile(replaceDirWithDefaultFile("$startloc/")))
  415.    {
  416.     $rootdir=$startloc;
  417.     $startloc=replaceDirWithDefaultFile("$startloc/");
  418.    }
  419.   else
  420.    {mortallyWounded("starting location","not recursable",__LINE__);}
  421.  }
  422.  
  423.  
  424. return;
  425. }
  426.  
  427.  
  428. sub isURL($){
  429. my $tempURL=shift;
  430. return 1 if ($tempURL=~m#^(https?|ftp)://#);
  431. return 0;
  432. }
  433.  
  434. sub combinePaths($$$){
  435. my $to=shift;
  436. my $from=shift;
  437. my $hasbase=shift;
  438. my $result;
  439.  
  440. $to=~s|^\./||;
  441. if ($hasbase)
  442.  {$to=~s|^$hasbase|/|;}
  443. else
  444.  {$to=~s|^$rootdir||;}
  445.  
  446. if (isURL($to) or $to=~/^mailto:/)
  447.  {$result=$to;}
  448. elsif ($to=~/\.\.\//)
  449.  {
  450.   my $numofmatches;
  451.   $numofmatches=($to=~s|\.\./||g);
  452.   $numofmatches=0 if $numofmatches eq "";
  453.   if ($from=~m|(.+/)(.+/){$numofmatches}.*$|)
  454.    {$result="$1$to";print "$1 + $to\n" if $DEBUG==2;}
  455.  }
  456. elsif ($to=~m|^/|)
  457.  {
  458.   if ($hasbase)
  459.    {
  460.     $to=~s|^/||;
  461.     $result="$hasbase$to";
  462.    }
  463.   else
  464.    {$result="$rootdir$to";}
  465.  }
  466. else
  467.  {
  468.   $from=~m|(.+/).*$|;
  469.   $result="$1$to";
  470.  }
  471.  
  472. debugMessage("combinePathsResult","$result",__LINE__) if $DEBUG;
  473.  
  474. return $result;
  475. }
  476.  
  477.  
  478.  
  479. sub printResult($$$$) {
  480. my $type=shift;
  481. my $to=shift;
  482. my $from=shift;
  483. my $line=shift;
  484. my $string;
  485.  
  486. $from=~s/$rootdir//; 
  487. $to=~s/$rootdir//; 
  488.  
  489. my $isurl=isURL($to);
  490.  
  491. $string.="::: " if ($easyparse);
  492.  
  493.  
  494. if ($type==$linkStatus{"success"} && $verbose)
  495.  {
  496.   if ($isurl)
  497.    {
  498.     if ($easyparse)     {$string.="ext+";}
  499.     else        {$string.="  external link exists";}
  500.    }
  501.   else
  502.    {
  503.     if ($easyparse)    {$string.="int+";}
  504.     else        {$string.="  internal link exists";}
  505.    }  
  506.  }
  507. elsif ($type==$linkStatus{"failure"})
  508.  {
  509.   if ($isurl && $to!~/$rootdir/)
  510.    {
  511.     if ($easyparse)     {$string.="ext-";}
  512.     else        {$string.=sprintf "%22s","external link failed";}
  513.    }
  514.   else
  515.    {
  516.     if ($easyparse)     {$string.="int-";}
  517.     else        {$string.=sprintf "%22s","internal link failed";}
  518.    }  
  519.  }
  520. elsif ($type==$linkStatus{"email"}&& $showEmailLinks)
  521.  {
  522.     if ($easyparse)     {$string.="e";}
  523.     else        {$string.=sprintf "%22s","can't check email link";}
  524.  }
  525. elsif ($type==$linkStatus{"protocolError"})
  526.  {
  527.     if ($easyparse)     {$string.="up";}
  528.     else        {$string.=sprintf "%22s","unsupported protocol";}
  529.  }
  530. elsif ($type==$linkStatus{"forbidden"})
  531.  {
  532.     if ($easyparse)     {$string.="f";}
  533.     else        {$string.=sprintf "%22s","forbidden";}
  534.  }
  535. elsif ($type==$linkStatus{"timeout"})
  536.  {
  537.     if ($easyparse)     {$string.="to";}
  538.     else        {$string.=sprintf "%22s","timed out";}
  539.  }
  540. else
  541.  {return;}
  542.  
  543. if ($easyparse)        {$string.=" :: $to :: $from";}
  544. else            {$string.=" : $to in $from";}
  545.  
  546. if ($showLineNumbers)
  547. {
  548.  if ($easyparse)    {$string.=" :: $line :::\n";}
  549.  else            {$string.=" line $line\n";}
  550. }
  551. else
  552. {
  553.  if ($easyparse)    {$string.=" :::\n";}
  554.  else            {$string.="\n";}
  555. }
  556.  
  557. print $string;
  558.  
  559. }
  560.  
  561. sub replaceDirWithDefaultFile($){
  562. my $file=shift;
  563. if ($file=~m#(.*)/$#)
  564.  {
  565.   my $a;
  566.   for ($a=0;$a<scalar @defaultFiles;$a++)
  567.    {
  568.     if (-e "$file$defaultFiles[$a]")
  569.      {
  570.       $file="$file$defaultFiles[$a]"; 
  571.       last;
  572.      }
  573.    }
  574.  }
  575. return $file;
  576. }
  577.  
  578. sub isRecursableURL($){
  579. my $URL=shift;
  580. return 1 if ($URL=~m#((\.s?html?)|/|(\.(asp|jsp|\w?cgi\d?|pl|php\d?|woa))(\?.+)?|(\?.*))$#i);
  581. return 0;
  582. }
  583.       
  584. sub isRecursableFile($){
  585. my $file=shift;
  586. return 1 if ($file=~m#(\.s?html?)|/$#i);
  587. return 0;
  588. }
  589.  
  590.  
  591. sub mortallyWounded($$$){
  592. my $category=shift;
  593. my $subcategory=shift;
  594. my $line=shift;
  595. my $string;
  596.  
  597. if ($easyparse)
  598.  {$string.="::: fatal :: $category :: $subcategory";}
  599. else
  600.  {$string.=sprintf("%22s : $category $subcategory","fatal");}
  601.  
  602. if ($showLineNumbers)
  603. {
  604. if ($easyparse)
  605.  {$string.=" :: $line :::\n";}
  606. else
  607.  {$string.=" line $line\n";}
  608. }
  609. else
  610. {
  611. if ($easyparse)
  612.  {$string.=" :::\n";}
  613. else
  614.  {$string.="\n";}
  615. } 
  616. print $string;
  617. exit 0;
  618. }
  619.  
  620. sub debugMessage($$$)
  621. {
  622. my $category=shift;
  623. my $subcategory=shift;
  624. my $line=shift;
  625. my $string;
  626.  
  627. if ($easyparse)
  628.  {$string.="::: debug :: $category :: $subcategory";}
  629. else
  630.  {$string.=sprintf("%22s : %22s ===> $subcategory","debug",$category);}
  631.  
  632. if ($showLineNumbers)
  633. {
  634. if ($easyparse)
  635.  {$string.=" :: $line :::\n";}
  636. else
  637.  {$string.=" line $line\n";}
  638. }
  639. else
  640. {
  641. if ($easyparse)
  642.  {$string.=" :::\n";}
  643. else
  644.  {$string.="\n";}
  645. } 
  646. print $string;
  647. }